home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / uflat2 / uflat2.c < prev    next >
C/C++ Source or Header  |  1991-06-18  |  32KB  |  1,186 lines
  1. /*
  2.    File: uflat2.c
  3. */
  4. #include <strings.h>
  5. #include <stdio.h>
  6. #include <tmc.h>
  7. #include <cvr.h>
  8. #include "uflat2const.h"
  9. #include "tmcode.h"
  10. #include "utils.h"
  11.  
  12. /* command line flags */
  13. static int showorig = TRUE;
  14. static int symtabtr = FALSE;
  15. static int stat = FALSE;
  16. static int orignames = FALSE;
  17.  
  18. /* common variables */
  19. #define infile stdin
  20. #define outfile stdout
  21. FILE *tracestream = stderr;
  22.  
  23. /* fields of definition to be monitored */
  24. typ intyp, outtyp;
  25. formcon deffc, newfc;
  26. val defval;
  27. def_list fcdefs;
  28.  
  29. typ *ctypes;
  30. int firstsrcnr;
  31. int nrofinputs;
  32.  
  33. /* definitions to be written to disk */
  34. def_list newdefs;
  35.  
  36. /* names of procs and locals */
  37. #define proclowend 100
  38. int procnr = proclowend;
  39.  
  40. /*
  41.    Table of debugging flags plus associated information.
  42.    Table is ended by an entry with flagchar '\0'
  43. */
  44. static dbflag flagtab[] =
  45.     {{ 's', &stat, "statistics" },
  46.      { 't', &symtabtr, "symbol table tracing" },
  47.      { '\0', (int *)0, "" },
  48.     };
  49.  
  50. #define streq(s1,s2) (strcmp ((s1),(s2)) == 0)
  51.  
  52. /*
  53.    Die with errormessage
  54. */
  55. static void Die (s)
  56.  char *s;    
  57.     { fprintf (stderr, "%s\n", s);
  58.       exit (1);
  59.     };
  60.  
  61. /*
  62.    Name from symbol.
  63.    Because the macroexpander adds _<number> to every symbol
  64.    we must remove that suffix when recognizing atoms or source symbols
  65. */
  66. static char* name_from_symbol (s)
  67.  symbol s;
  68.     { char Buf[80];
  69.       char *name = symbolstr (s);
  70.       int ix;
  71.       for (ix = 0; ix < strlen (name) && !(name[ix] == '_'); ix++)
  72.          Buf [ix] = name [ix];
  73.       Buf [ix] ='\0';
  74.       return (new_string (Buf));
  75.     };
  76.  
  77. /*
  78.    Create an unique symbol
  79. */
  80. static int uniquenr = 0;
  81. static symbol unique_name ()
  82.     { char Buf[20];
  83.       symbol new;
  84.       sprintf (Buf, "l_'_%d", uniquenr);
  85.       new = addsymbol (new_string (Buf));
  86.       setprior (new, uniquenr);
  87.       uniquenr++;
  88.       return (new);
  89.     };
  90.  
  91. /*
  92.    Give the formal connection parameters of a def
  93.    a procedure nr. We will need it to deduce types.
  94. */
  95. static void prepare1_formcon (fc)
  96.  formcon fc;
  97.     { switch (fc -> tag)
  98.          { case TAGFCSym:
  99.           { setprior (fc -> FCSym.sym, procnr);
  100.             procnr++;
  101.           };
  102.           break;
  103.            case TAGFCList:
  104.           { register ix;
  105.             formcon_list fcl = fc -> FCList.l;
  106.             for (ix = 0; ix < fcl -> sz; ix++)
  107.                prepare1_formcon (fcl -> arr[ix]);
  108.           };
  109.           break;
  110.            default: badtag (fc -> tag);
  111.          };
  112.     };
  113.  
  114. /*
  115.    Find the type belonging to each 'fc'.
  116.    Do also some consistency checks.
  117. */
  118. static void prepare2_formcon (fc,t)
  119.  formcon fc;
  120.  typ t;
  121.     { switch (fc -> tag)
  122.          { case TAGFCSym:
  123.           { symbol sy = fc -> FCSym.sym;
  124.             int nr = getprior (sy);
  125.             ctypes [nr - proclowend] = rdup_typ (t);
  126.           };
  127.           break;
  128.            case TAGFCList:
  129.           { formcon_list fcl = fc -> FCList.l;
  130.             register int ix;
  131.             typ_list tl;
  132.             if (t -> tag != TAGTypProd)
  133.                Die ("type should be product type");
  134.             tl = t -> TypProd.ptypes;
  135.             if (fcl -> sz != tl -> sz)
  136.               Die ("formcon list and type list should have equal size");
  137.             for (ix=0; ix < fcl -> sz; ix++)
  138.                prepare2_formcon (fcl -> arr[ix], tl -> arr[ix]);
  139.               };
  140.           break;
  141.            default: badtag (fc -> tag);
  142.          };
  143.     };
  144.  
  145. /*
  146.    Prepare formal parameters of the definition
  147. */
  148. static void prepare_formcon (fc, t)
  149.  formcon fc;
  150.  typ t;
  151.     { int ix;
  152.       firstsrcnr = procnr;
  153.       prepare1_formcon (fc);
  154.       nrofinputs = procnr - firstsrcnr;
  155.       ctypes = (typ*) ckcalloc (procnr+1, sizeof (typ));
  156.       for (ix=0; ix < procnr; ix++) ctypes[ix] = typNIL;
  157.       prepare2_formcon (fc, t);
  158.     };
  159.  
  160. /* Given a symbol 's', search the context for a definition with
  161.  * that name, and return a pointer to it.
  162.  */
  163. static ctx_list context;
  164.  
  165. static int symbol_occurs_in (s, v)
  166.  symbol s;
  167.  val v;
  168.     { switch (v -> tag)
  169.          { case TAGVSym: return (v -> VSym.sym == s);
  170.            case TAGVList:
  171.           { val_list vl = v -> VList.l;
  172.             register int ix;
  173.             for (ix=0; ix < vl -> sz; ix++)
  174.                if (symbol_occurs_in (s, vl -> arr[ix])) return (1);
  175.             return (0);
  176.           };
  177.            default: badtag (v -> tag);
  178.          };
  179.     };
  180.           
  181. static def find_def (s)
  182.  symbol s;
  183.     { register unsigned int cix;
  184.       register unsigned int dix;
  185.  
  186.       for (cix = 0; cix < context -> sz; cix++)
  187.          { register def_list l = context -> arr[cix] -> defs;
  188.            for (dix = 0; dix < l -> sz; dix++)
  189.           { register def d = l -> arr[dix];
  190.             switch (d -> tag)
  191.                { case TAGDefAtom:
  192.                     if (d -> DefAtom.atnm == s) return (d);
  193.                     break;
  194.  
  195.                  case TAGDefBasetype:
  196.                     if (d -> DefBasetype.basename == s) return (d);
  197.                     break;
  198.  
  199.              case TAGDefVal:
  200.                 if (d -> DefVal.valnm == s) return (d);
  201.                     break;
  202.  
  203.              case TAGDefTyp:
  204.                     if (d -> DefTyp.typnm == s) return (d);
  205.                     break;
  206.  
  207.              case TAGDefCon:
  208.                 Die ("DefCon should have been removed");
  209.              case TAGDefConTr:
  210.                 if (symbol_occurs_in (s, d -> DefConTr.lhs))
  211.                    return (d);
  212.                 break;
  213.              default:
  214.                     badtag (d -> tag);
  215.                    };
  216.           };
  217.     }
  218.     return (defNIL);
  219.     };
  220.  
  221. /* Copy all global basetype and atom definitions */
  222. static copy_basenamedefs (new, old)
  223.  def_list new, old;
  224.     { register int ix;
  225.       register def d;
  226.       for (ix = 0; ix < old -> sz; ix++)
  227.          { d = old -> arr[ix];
  228.            switch (d -> tag)
  229.           { case TAGDefAtom:
  230.                app_def_list (new, rdup_def (d));
  231.                break;
  232.             case TAGDefBasetype:
  233.                app_def_list (new, rdup_def (d));
  234.                break;
  235.             case TAGDefVal:
  236.                break;
  237.             case TAGDefCon:
  238.             case TAGDefTyp:
  239.             default:
  240.                badtag (d -> tag);
  241.                break;
  242.           };
  243.          };
  244.     };
  245.  
  246. /* Print usage of this program */
  247. static void usage (f)
  248.  FILE *f;
  249.      { fprintf (f, "Usage: uflat2 [-n] [-h] [-d<debugging flags>]\n");
  250.       helpdbflags (f, flagtab);
  251.     };
  252.  
  253. /* scan arguments and options */
  254. static void scanargs (argc, argv)
  255.  int argc;
  256.  char *argv[];
  257.     { int op;
  258.       argv++;
  259.       argc--;
  260.       while (argc>0)
  261.          { if (argv[0][0] != '-')
  262.           { fprintf (stderr, "too many arguments\n");
  263.             usage (stderr);
  264.             exit (1);
  265.           };
  266.            op = argv[0][1];
  267.            switch (op)
  268.          { case 'd': setdbflags (&argv[0][2], flagtab, TRUE);
  269.                  break;
  270.            case 'h':
  271.            case 'H': usage (stdout);
  272.                  exit (0);
  273.            case 'o': showorig = FALSE;
  274.                  break;
  275.            case 'n': orignames = TRUE;
  276.                  break;
  277.            default: usage (stderr);
  278.                 exit (1);
  279.              };
  280.            argc--;
  281.            argv++;
  282.          };
  283.     };
  284.  
  285. static def find_thedef (dl)
  286.  def_list dl;
  287.     { register int ix;
  288.       register def d;
  289.       register def mdef = defNIL;
  290.       for (ix = 0; ix < dl -> sz; ix++)
  291.          { d = dl -> arr[ix];
  292.            if (d -> tag == TAGDefVal)
  293.           { if (mdef == defNIL)
  294.                { mdef = d;
  295.                }
  296.             else Die ("More than one codible definition found");
  297.           };
  298.          };
  299.       if (mdef == defNIL) Die ("No codible definition found");
  300.       return (mdef);
  301.     };
  302.  
  303. /*
  304.    Prepare the value to be coded:
  305.    Record procedure nrs for right hand sides of local definitions:
  306.    Introduce also local definitions for atoms with internal feedback
  307.    like the jkff and tff.
  308. */
  309. static val prepare_val (v)
  310.  val v;
  311.     { switch (v -> tag)
  312.          { case TAGVSym: return (rdup_val (v));
  313.            case TAGVWhere:
  314.           { register ix;
  315.             def_list ndl = new_def_list ();
  316.             def_list dl = v -> VWhere.wdefs;
  317.             room_def_list (ndl, dl -> sz);
  318.             ndl -> sz = dl -> sz;
  319.             for (ix = 0; ix < dl -> sz; ix++)
  320.                { register def d = dl -> arr [ix];
  321.              val newrhs;
  322.              if (d -> tag != TAGDefCon)
  323.                 Die ("Only local connections allowed");
  324.              newrhs = prepare_val (d -> DefCon.conas);
  325.              ndl -> arr [ix] =
  326.                 new_DefConTr (rdup_orig (d -> DefCon.conorig),
  327.                     rdup_val (d -> DefCon.defcon),
  328.                     newrhs, procnr);
  329.              procnr++;
  330.                };
  331.             return (new_VWhere (ndl, prepare_val (v -> VWhere.wval)));
  332.           };
  333.            case TAGVList:
  334.           { register ix;
  335.             val_list vl = v -> VList.l;
  336.             val_list nvl = new_val_list ();
  337.             room_val_list (nvl, vl -> sz);
  338.             nvl -> sz = vl -> sz;
  339.             for (ix=0; ix < vl -> sz; ix++)
  340.                nvl -> arr [ix] = prepare_val (vl -> arr[ix]);
  341.             return (new_VList (nvl));
  342.           };
  343.            case TAGVAtom:
  344.           { return (new_VAtom (rdup_orig (v -> VAtom.atorig),
  345.                     rdup_symbol (v -> VAtom.atnm),
  346.                     rdup_parval_list (v -> VAtom.atvpar),
  347.                     prepare_val (v -> VAtom.atcpar)));
  348.           };
  349.            case TAGVLambda:
  350.            case TAGVSigma:
  351.            case TAGVApply:
  352.            case TAGVAppset:
  353.            case TAGVSyn:
  354.           Die ("Only wheres, atom applications, lists and symbols are allowed");
  355.            default:
  356.           badtag (v -> tag);
  357.          };
  358.     };
  359.  
  360. /*
  361.    prepare types
  362. */
  363. static typ partial_build_typ (v, s, t)
  364.  val v;
  365.  symbol s;
  366.  typ t;
  367.     { switch (v -> tag)
  368.          { case TAGVSym:
  369.               { if (v -> VSym.sym == s) return (rdup_typ (t));
  370.             return (typNIL);
  371.           };
  372.            case TAGVList:
  373.           { register int ix;
  374.             val_list vl = v -> VList.l;
  375.             typ_list tl = new_typ_list ();
  376.             room_typ_list (tl, vl -> sz);
  377.             tl -> sz = vl -> sz;
  378.             for (ix=0; ix < vl -> sz; ix++)
  379.                tl -> arr[ix] = partial_build_typ (vl -> arr[ix], s, t);
  380.             return (new_TypProd (tl));
  381.           };
  382.            default: badtag (v -> tag);
  383.          };
  384.     };
  385.  
  386. /*
  387.    Unify types
  388. */
  389. static typ unify_types (t1,t2)
  390.  typ t1,t2;
  391.     { if (t1 == typNIL) return (rdup_typ (t2));
  392.       if (t2 == typNIL) return (rdup_typ (t1));
  393.       if (t1 -> tag != t2 -> tag) Die ("Can not unify types");
  394.       switch (t1 -> tag)
  395.          { case TAGTypBase: return (rdup_typ (t1));
  396.            case TAGTypProd:
  397.           { typ_list t1l = t1 -> TypProd.ptypes;
  398.             typ_list t2l = t2 -> TypProd.ptypes;
  399.             typ_list ntl = new_typ_list ();
  400.             register int ix;
  401.             if (t1l -> sz != t2l -> sz) Die ("Can not unify types");
  402.             room_typ_list (ntl, t1l -> sz);
  403.             ntl -> sz = t1l -> sz;
  404.             for (ix=0; ix < t1l -> sz; ix++)
  405.                ntl -> arr[ix] = unify_types (t1l -> arr[ix],
  406.                         t2l -> arr[ix]);
  407.             return (new_TypProd (ntl));
  408.           };
  409.            default: badtag (t1 -> tag);
  410.          };
  411.     };
  412.  
  413. static void update_type_in_def (d, t)
  414.  def d;
  415.  typ t;
  416.     { int nr = d -> DefConTr.nr - proclowend;
  417.       typ newtyp = unify_types (ctypes [nr], t);
  418.       rfre_typ (ctypes [nr]);
  419.       ctypes [nr] = newtyp;
  420.     };
  421.  
  422. static typ deduce_types_in_val ();
  423. static void deduce_types_in_def (d)
  424.  def d;
  425.     { int nr = d -> DefConTr.nr - proclowend;
  426.       typ t = deduce_types_in_val (d -> DefConTr.rhs, ctypes [nr]);
  427.       update_type_in_def (d,t);
  428.       rfre_typ (t);
  429.     };
  430.  
  431. static typ project_type (t, v, s)
  432.  typ t;
  433.  val v;
  434.  symbol s;
  435.     { if (t == typNIL) return (typNIL);
  436.       switch (v -> tag)
  437.          { case TAGVSym:
  438.           { if (v -> VSym.sym == s) return (rdup_typ (t));
  439.             return (typNIL);
  440.           };
  441.            case TAGVList:
  442.           { register int ix;
  443.             typ rettyp;
  444.             typ_list tl = t -> TypProd.ptypes;
  445.             val_list vl = v -> VList.l;
  446.             for (ix=0; ix < vl -> sz; ix++)
  447.                if ((rettyp = project_type (tl -> arr[ix],
  448.                     vl -> arr[ix], s)) != typNIL)
  449.               return (rettyp);
  450.             return (typNIL);
  451.           };
  452.            default: badtag (v -> tag);
  453.          };
  454.     };
  455.  
  456. static typ deduce_types_in_val (v,t)
  457.  val v;
  458.  typ t;
  459.     { switch (v -> tag)
  460.          { case TAGVSym:
  461.           { symbol sy = v -> VSym.sym;
  462.             def d;
  463.             int nr = getprior (sy);
  464.             if (nr >= firstsrcnr)
  465.                return (rdup_typ (ctypes [nr - proclowend]));
  466.             if ((d = find_def (sy)) == defNIL)
  467.                Die ("definition not found");
  468.             if (t != typNIL)
  469.                { typ parttyp = partial_build_typ
  470.                 (d -> DefConTr.lhs, sy, t);
  471.                  update_type_in_def (d, parttyp);
  472.              rfre_typ (parttyp);
  473.                };
  474.             nr = d -> DefConTr.nr;
  475.             return (project_type (ctypes[nr - proclowend],
  476.                 d -> DefConTr.lhs, sy));
  477.           };
  478.            case TAGVList:
  479.           { val_list vl = v -> VList.l;
  480.             typ_list gtl = typ_listNIL;
  481.             int ix;
  482.             typ_list ntl = new_typ_list ();
  483.             room_typ_list (ntl, vl -> sz);
  484.             ntl -> sz = vl -> sz;
  485.             if (t != typNIL)
  486.                { if ((t -> tag != TAGTypProd) ||
  487.                      (t -> TypProd.ptypes -> sz != vl -> sz))
  488.                     Die ("Mismatch between type and value");
  489.              gtl = rdup_typ_list (t -> TypProd.ptypes);
  490.                };
  491.             for (ix=0; ix < ntl -> sz; ix++)
  492.                ntl -> arr[ix] = deduce_types_in_val (vl -> arr[ix],
  493.                       (t==typNIL)?typNIL:gtl -> arr[ix]);
  494.             rfre_typ_list (gtl);
  495.             return (new_TypProd (ntl));
  496.           };
  497.            case TAGVAtom:
  498.           { symbol atnm = v -> VAtom.atnm;
  499.             def d = find_def (atnm);
  500.             typ dummy = deduce_types_in_val (v -> VAtom.atcpar,
  501.                     d -> DefAtom.atctyp -> TypUni.uityp);
  502.             rfre_typ (dummy);
  503.             return (rdup_typ (d -> DefAtom.atctyp -> TypUni.uotyp));
  504.           };
  505.            case TAGVWhere:
  506.           { typ dummy, rettyp;
  507.             typ srctyp = rdup_typ (t);    /* t may be overwritten */
  508.             def_list dl = v -> VWhere.wdefs;
  509.             int ix;
  510.             ins_ctx_list (context, 0, new_ctx (rdup_def_list (dl)));
  511.             if (t != typNIL)
  512.                dummy = deduce_types_in_val (v -> VWhere.wval, srctyp);
  513.             for (ix=0; ix < dl -> sz; ix++)
  514.                deduce_types_in_def (dl -> arr[ix]);
  515.             rettyp = deduce_types_in_val (v -> VWhere.wval, srctyp);
  516.             rfre_typ (dummy);
  517.             rfre_typ (srctyp);
  518.             del_ctx_list (context, 0);
  519.             return (rettyp);
  520.           };
  521.            default: badtag (v -> tag);
  522.          };
  523.     };
  524.  
  525. static void deduce_all_where_types ()
  526.     { typ dummy;
  527.       context = new_ctx_list ();
  528.       ins_ctx_list (context, 0, new_ctx (rdup_def_list (newdefs)));
  529.       dummy = deduce_types_in_val (defval, outtyp);
  530.       rfre_typ (dummy);
  531.       rfre_ctx_list (context);
  532.     };
  533.  
  534. /*
  535.    check if the types of all right hand sides are defined
  536. */
  537. static int fully_defined (t)
  538.  typ t;
  539.     { switch (t -> tag)
  540.          { case TAGTypBase: return (1);
  541.            case TAGTypProd:
  542.           { typ_list tl = t -> TypProd.ptypes;
  543.             register int ix;
  544.             for (ix=0; ix < tl -> sz; ix++)
  545.                if (!fully_defined (tl -> arr[ix]))
  546.               return (0);
  547.             return (1);
  548.           };
  549.            default: badtag (t -> tag);
  550.          };
  551.     };
  552.  
  553. static void check_if_all_types_defined ()
  554.     { int ix;
  555.       for (ix=0; ix < procnr-proclowend; ix++)
  556.          if (!fully_defined (ctypes[ix]))
  557.         Die ("Not all types could be found");
  558.     };
  559.  
  560. static void prepare_types ()
  561.     { deduce_all_where_types ();
  562.       check_if_all_types_defined ();
  563.     };
  564.  
  565. /*
  566.    Now that you know every type, rewrite all symbols,
  567.    so that what remains only contains local symbols having
  568.    the basetype as type
  569. */
  570. static formcon unique_formcon_of_type (t)
  571.  typ t;
  572.     { switch (t -> tag)
  573.          { case TAGTypBase:
  574.           return (new_FCSym (unique_name ()));
  575.            case TAGTypProd:
  576.           { register int ix;
  577.             typ_list tl = t -> TypProd.ptypes;
  578.             formcon_list nfc = new_formcon_list ();
  579.             room_formcon_list (nfc, tl -> sz);
  580.             nfc -> sz = tl -> sz;
  581.             for (ix = 0; ix < tl -> sz; ix++)
  582.                nfc -> arr[ix] = unique_formcon_of_type (tl -> arr[ix]);
  583.             return (new_FCList (nfc));
  584.           };
  585.            default: badtag (t -> tag);
  586.          };
  587.     };
  588.  
  589. static val formcon_to_val (org, fc)
  590.  orig org;
  591.  formcon fc;
  592.     { switch (fc -> tag)
  593.          { case TAGFCSym:
  594.           return (new_VSym (rdup_orig (org),
  595.                 rdup_symbol (fc -> FCSym.sym)));
  596.            case TAGFCList:
  597.           { register int ix;
  598.             formcon_list fcl = fc -> FCList.l;
  599.             val_list nvl = new_val_list ();
  600.             room_val_list (nvl, fcl -> sz);
  601.             nvl -> sz = fcl -> sz;
  602.             for (ix = 0; ix < nvl -> sz; ix++)
  603.                nvl -> arr [ix] = formcon_to_val (org, fcl -> arr [ix]);
  604.             return (new_VList (nvl));
  605.           };
  606.            default: badtag (fc -> tag);
  607.          };
  608.     };
  609.  
  610. static val unique_val_of_type (org, t)
  611.  orig org;
  612.  typ t;
  613.     { switch (t -> tag)
  614.          { case TAGTypBase:
  615.           return (new_VSym (rdup_orig (org), unique_name ()));
  616.            case TAGTypProd:
  617.           { register int ix;
  618.             typ_list tl = t -> TypProd.ptypes;
  619.             val_list nvl = new_val_list ();
  620.             room_val_list (nvl, tl -> sz);
  621.             nvl -> sz = tl -> sz;
  622.             for (ix = 0; ix < tl -> sz; ix++)
  623.                nvl -> arr[ix] = unique_val_of_type (org, tl -> arr[ix]);
  624.             return (new_VList (nvl));
  625.           };
  626.            default: badtag (t -> tag);
  627.          };
  628.     };
  629.  
  630. static formcon add_to_repls_from_fc (repls, org, fc, fcdefs)
  631.  repl_list repls;
  632.  orig org;
  633.  formcon fc;
  634.  def_list fcdefs;
  635.     { switch (fc -> tag)
  636.          { case TAGFCSym:
  637.           { int nr = getprior (fc -> FCSym.sym);
  638.             formcon unfc = unique_formcon_of_type
  639.                     (ctypes [nr - proclowend]);
  640.             val unval = formcon_to_val (org, unfc);
  641.             app_repl_list (repls, new_repl
  642.                 (rdup_symbol (fc -> FCSym.sym), unval));
  643.             app_def_list (fcdefs, new_DefCon (rdup_orig (org),
  644.                         rdup_val (unval),
  645.                         formcon_to_val (org, fc)));
  646.             return (unfc);
  647.           };
  648.           break;
  649.            case TAGFCList:
  650.           { register ix;
  651.             formcon_list fcl = fc -> FCList.l;
  652.             formcon_list nfcl = new_formcon_list ();
  653.             room_formcon_list (nfcl, fcl -> sz);
  654.             nfcl -> sz = fcl -> sz;
  655.             for (ix = 0; ix < fcl -> sz; ix++)
  656.                nfcl -> arr [ix] = add_to_repls_from_fc
  657.                         (repls, org,
  658.                          fcl -> arr[ix], fcdefs);
  659.             return (new_FCList (nfcl));
  660.           };
  661.           break;
  662.            default: badtag (fc -> tag);
  663.          };
  664.     };
  665.  
  666. static void add_to_repls_from_val (repls, org, v, t)
  667.  repl_list repls;
  668.  orig org;
  669.  val v;
  670.  typ t;
  671.     { switch (v -> tag)
  672.          { case TAGVSym: 
  673.           { val newlocs = unique_val_of_type (org, t);
  674.             app_repl_list (repls, new_repl
  675.                 (rdup_symbol (v -> VSym.sym), newlocs));
  676.           };
  677.           break;
  678.            case TAGVList:
  679.           { val_list vl = v -> VList.l;
  680.             typ_list tl = t -> TypProd.ptypes;
  681.             register int ix;
  682.             for (ix = 0; ix < vl -> sz; ix++)
  683.                add_to_repls_from_val (repls, org, vl -> arr[ix],
  684.                         tl -> arr[ix]);
  685.           };
  686.           break;
  687.            default: badtag (v -> tag);
  688.          };
  689.     };
  690.  
  691. static repl_list repls_from_local_defs (dl)
  692.  def_list dl;
  693.     { register int ix;
  694.       repl_list nrepls = new_repl_list ();
  695.       for (ix = 0; ix < dl -> sz; ix++)
  696.          { def d = dl -> arr[ix];
  697.            add_to_repls_from_val (nrepls, d -> DefConTr.corig,
  698.                     d -> DefConTr.lhs,
  699.                     ctypes [d -> DefConTr.nr - proclowend]);
  700.          };
  701.       return (nrepls);
  702.     };
  703.  
  704. static val make_names_unique_in_val ();
  705. static def make_names_unique_in_def (repls, d)
  706.  repl_list repls;
  707.  def d;
  708.     { val nlhs, nrhs;
  709.       nlhs = make_names_unique_in_val (repls, d -> DefConTr.lhs);
  710.       nrhs = make_names_unique_in_val (repls, d -> DefConTr.rhs);
  711.       return (new_DefConTr (rdup_orig (d -> DefConTr.corig),
  712.                 nlhs, nrhs,
  713.                 d -> DefConTr.nr));
  714.     };
  715.  
  716. static val make_names_unique_in_val (repls, v)
  717.  repl_list repls;
  718.  val v;
  719.     { switch (v -> tag)
  720.          { case TAGVSym:
  721.           { register int ix;
  722.             for (ix=0; ix < repls -> sz; ix++)
  723.                if (v -> VSym.sym == repls -> arr[ix] -> rsym)
  724.               return (rdup_val (repls -> arr[ix] -> repval));
  725.             return (rdup_val (v));
  726.           };
  727.            case TAGVList:
  728.           { register int ix;
  729.             val_list vl = v -> VList.l;
  730.             val_list nvl = new_val_list ();
  731.             room_val_list (nvl, vl -> sz);
  732.             nvl -> sz = vl -> sz;
  733.             for (ix = 0; ix < vl -> sz; ix++)
  734.             nvl -> arr [ix] = make_names_unique_in_val
  735.                 (repls, vl -> arr[ix]);
  736.             return (new_VList (nvl));
  737.           };
  738.            case TAGVAtom:
  739.           { return (new_VAtom (rdup_orig (v -> VAtom.atorig),
  740.                 rdup_symbol (v -> VAtom.atnm),
  741.                 rdup_parval_list (v -> VAtom.atvpar),
  742.                 make_names_unique_in_val
  743.                     (repls, v -> VAtom.atcpar)));
  744.           };
  745.            case TAGVWhere:
  746.           { val newwval, retval;
  747.             repl_list locreps;
  748.             register int ix;
  749.             def_list ldefs = v -> VWhere.wdefs;
  750.             def_list ndefs = new_def_list ();
  751.             room_def_list (ndefs, ldefs -> sz);
  752.             ndefs -> sz = ldefs -> sz;
  753.             locreps = repls_from_local_defs (ldefs);
  754.             conc_repl_list (locreps, rdup_repl_list (repls));
  755.             newwval = make_names_unique_in_val
  756.                         (locreps, v -> VWhere.wval);
  757.             for (ix=0; ix < ldefs -> sz; ix++)
  758.                ndefs -> arr [ix] = make_names_unique_in_def
  759.                         (locreps, ldefs -> arr[ix]);
  760.             retval = new_VWhere (ndefs, newwval);
  761.             rfre_repl_list (locreps);
  762.             return (retval);
  763.           };
  764.            default: badtag (v -> tag);
  765.          };
  766.     };
  767.  
  768. static val make_all_names_unique (org)
  769.  orig org;
  770.     { val newval;
  771.       repl_list first_repls = new_repl_list ();
  772.       fcdefs = new_def_list ();
  773.       newfc = add_to_repls_from_fc (first_repls, org, deffc, fcdefs);
  774.       newval = make_names_unique_in_val (first_repls, defval);
  775.       rfre_repl_list (first_repls);
  776.       return (newval);
  777.     };
  778.  
  779. /*
  780.    Now that symbols are unique merge all local
  781.    definitions into one where clause
  782. */
  783. static val merge_all_wheres_in_val ();
  784. static void merge_all_wheres_in_def (d, ndefs)
  785.  def d;
  786.  def_list ndefs;
  787.     { val nrhs = merge_all_wheres_in_val (d -> DefConTr.rhs, ndefs);
  788.       val nlhs = rdup_val (d -> DefConTr.lhs);
  789.       def ndef = new_DefConTr (rdup_orig (d -> DefConTr.corig),
  790.                     nlhs, nrhs, d -> DefConTr.nr);
  791.       app_def_list (ndefs, ndef);
  792.     };
  793.  
  794. static val merge_all_wheres_in_val (v, ndefs)
  795.  val v;
  796.  def_list ndefs;    
  797.     { switch (v -> tag)
  798.          { case TAGVSym:
  799.           return (rdup_val (v));
  800.            case TAGVList:
  801.           { register int ix;
  802.             val_list vl = v -> VList.l;
  803.             val_list nvl = new_val_list ();
  804.             room_val_list (nvl, vl -> sz);
  805.             nvl -> sz = vl -> sz;
  806.             for (ix = 0; ix < vl -> sz; ix++)
  807.                nvl -> arr[ix] = merge_all_wheres_in_val
  808.                         (vl -> arr[ix], ndefs);
  809.             return (new_VList (nvl));
  810.           };
  811.            case TAGVAtom:
  812.           return (new_VAtom (rdup_orig (v -> VAtom.atorig),
  813.                 rdup_symbol (v -> VAtom.atnm),
  814.                 rdup_parval_list (v -> VAtom.atvpar),
  815.                 merge_all_wheres_in_val
  816.                     (v -> VAtom.atcpar, ndefs)));
  817.            case TAGVWhere:
  818.           { def_list dl = v -> VWhere.wdefs;
  819.             register int ix;
  820.             for (ix = 0; ix < dl -> sz; ix++)
  821.             merge_all_wheres_in_def (dl -> arr [ix], ndefs);
  822.             return (merge_all_wheres_in_val (v -> VWhere.wval, ndefs));
  823.           };
  824.            default: badtag (v -> tag);
  825.          };
  826.     };
  827.  
  828. static val merge_all_wheres (org, v, t)
  829.  orig org;
  830.  val v;
  831.  typ t;
  832.     { val nlhs = unique_val_of_type (org, t);
  833.       def_list ndefs = new_def_list ();
  834.       val nrhs = merge_all_wheres_in_val (v, ndefs);
  835.       def ndef = new_DefConTr (rdup_orig (org), rdup_val (nlhs),
  836.                     nrhs, procnr);
  837.       ctypes [procnr - proclowend] = rdup_typ (t);
  838.       procnr++;
  839.       app_def_list (ndefs, ndef);
  840.       return (new_VWhere (ndefs, nlhs));
  841.     };
  842.  
  843. /*
  844.    unfold all defs so that atom applications no longer have
  845.    atom applications as actual arguments.
  846. */
  847. static val try_unfold_atoms_in_val (v, ndefs)
  848.  val v;
  849.  def_list ndefs;
  850.     { switch (v -> tag)
  851.          { case TAGVSym:
  852.           return (rdup_val (v));
  853.            case TAGVList:
  854.           { register int ix;
  855.             val_list vl = v -> VList.l;
  856.             val_list nvl = new_val_list ();
  857.             room_val_list (nvl, vl -> sz);
  858.             nvl -> sz = vl -> sz;
  859.             for (ix = 0; ix < vl -> sz; ix++)
  860.                nvl -> arr[ix] = try_unfold_atoms_in_val
  861.                         (vl -> arr[ix], ndefs);
  862.             return (new_VList (nvl));
  863.           };
  864.            case TAGVAtom:
  865.           { val atcarg = v -> VAtom.atcpar;
  866.             def d = find_def (v -> VAtom.atnm);
  867.             typ atctyp = d -> DefAtom.atctyp -> TypUni.uityp;
  868.             val newatc = try_unfold_atoms_in_val (atcarg, ndefs);
  869.             val nlhs = unique_val_of_type
  870.                   (rdup_orig (v -> VAtom.atorig), atctyp);
  871.             def newdef = new_DefCon 
  872.                   (rdup_orig (v -> VAtom.atorig), nlhs, newatc);
  873.             app_def_list (ndefs, newdef);
  874.             return (new_VAtom (rdup_orig (v -> VAtom.atorig),
  875.                     rdup_symbol (v -> VAtom.atnm),
  876.                     rdup_parval_list (v -> VAtom.atvpar),
  877.                     rdup_val (nlhs)));
  878.           };
  879.            default: badtag (v -> tag);
  880.          };
  881.     };
  882.  
  883. static void try_unfold_atoms_in_def (d, ndefs)
  884.  def d;
  885.  def_list ndefs;
  886.     { val nlhs = rdup_val (d -> DefConTr.lhs);
  887.       val nrhs = try_unfold_atoms_in_val (d -> DefConTr.rhs, ndefs); 
  888.       def ndef = new_DefCon (rdup_orig (d -> DefConTr.corig), nlhs, nrhs);
  889.       app_def_list (ndefs, ndef);
  890.     };
  891.  
  892. static val try_unfold_atoms (v)
  893.  val v;
  894.     { register int ix;
  895.       val trhs = rdup_val (v -> VWhere.wval);
  896.       def_list odefs = v -> VWhere.wdefs;
  897.       def_list ndefs = new_def_list ();
  898.       room_def_list (ndefs, odefs -> sz);
  899.       context = new_ctx_list ();
  900.       ins_ctx_list (context, 0, new_ctx (rdup_def_list (newdefs)));
  901.       for (ix = 0; ix < odefs -> sz; ix++)
  902.          try_unfold_atoms_in_def (odefs -> arr[ix], ndefs);
  903.       rfre_ctx_list (context);
  904.       return (new_VWhere (ndefs, trhs));
  905.     };
  906.  
  907. /*
  908.    Try and split all definitions into single wire ones
  909. */
  910. static void try_form_separate_defs (org, lhs, rhs, ndefs)
  911.  orig org;
  912.  val lhs, rhs;
  913.  def_list ndefs;
  914.     { val_list lvl, rvl;
  915.       register int ix;
  916.       if ((rhs -> tag == TAGVAtom) ||
  917.           (rhs -> tag == TAGVSym) ||
  918.           (lhs -> tag == TAGVSym))
  919.          { def nd = new_DefCon (rdup_orig (org), rdup_val (lhs),
  920.                     rdup_val (rhs));
  921.            app_def_list (ndefs, nd);
  922.            return;
  923.          };
  924.       lvl = lhs -> VList.l;
  925.       rvl = rhs -> VList.l;
  926.       if (lvl -> sz != rvl -> sz) Die ("Incompatible sizes");
  927.       for (ix = 0; ix < lvl -> sz; ix++)
  928.          try_form_separate_defs (org, lvl -> arr[ix],
  929.                     rvl -> arr[ix], ndefs);
  930.  
  931.     };
  932.  
  933. static val try_split_defs (v)
  934.  val v;
  935.     { register int ix;
  936.       val trhs = rdup_val (v -> VWhere.wval);
  937.       def_list odefs = v -> VWhere.wdefs;
  938.       def_list ndefs = new_def_list ();
  939.       room_def_list (ndefs, odefs -> sz);
  940.       for (ix = 0; ix < odefs -> sz; ix++)
  941.          { def d = odefs -> arr[ix];
  942.            try_form_separate_defs (d -> DefCon.conorig, d -> DefCon.defcon,
  943.                     d -> DefCon.conas, ndefs);
  944.          };
  945.       return (new_VWhere (ndefs, trhs));
  946.     };
  947.  
  948. /*
  949.    try and simplify the definitions so that only the external inputs
  950.    and outputs and the intermediair contacts appear in the defs.
  951. */
  952. static int *local_xref, *local_xref_trans;
  953. static val *local_val;
  954.  
  955. #define no_appear (-2)
  956. #define must_appear (-1)
  957. static mark_symbol (s, org, alt)
  958.  symbol s;
  959.  orig org;
  960.  int alt;
  961.     { int nr = getprior (s);
  962.       local_xref [nr] = alt;
  963.       if (alt == must_appear) local_xref_trans [nr] = alt;
  964.       local_val [nr] = new_VSym (org, s);
  965.     };
  966.  
  967. static void mark_symbols_in_fc (org, fc)
  968.  orig org;
  969.  formcon fc;
  970.     { switch (fc -> tag)
  971.          { case TAGFCSym:
  972.           mark_symbol (fc -> FCSym.sym, org, must_appear);
  973.           break;
  974.            case TAGFCList:
  975.           { formcon_list fcl = fc -> FCList.l;
  976.             register int ix;
  977.             for (ix = 0; ix < fcl -> sz; ix++)
  978.                mark_symbols_in_fc (org, fcl -> arr[ix]);
  979.           };
  980.           break;
  981.            default: badtag (fc -> tag);
  982.          };
  983.     };
  984.  
  985. static void mark_symbols_in_val (v)
  986.  val v;
  987.     { switch (v -> tag)
  988.          { case TAGVSym:
  989.           mark_symbol (v -> VSym.sym, v -> VSym.symorig, must_appear);
  990.           break;
  991.            case TAGVList:
  992.           { val_list vl = v -> VList.l;
  993.             register int ix;
  994.             for (ix = 0; ix < vl -> sz; ix++)
  995.                mark_symbols_in_val (vl -> arr[ix]);
  996.           };
  997.           break;
  998.            default: badtag (v -> tag);
  999.          };
  1000.     };
  1001.  
  1002. static void try_mark_in_def (d)
  1003.  def d;
  1004.     { val lhs = d -> DefCon.defcon;
  1005.       val rhs = d -> DefCon.conas;
  1006.       if (rhs -> tag == TAGVAtom)
  1007.          { mark_symbols_in_val (lhs);
  1008.          }
  1009.       else if ((lhs -> tag == TAGVSym) &&
  1010.            (rhs -> tag == TAGVSym))
  1011.          { mark_symbol (lhs -> VSym.sym, lhs -> VSym.symorig,
  1012.                 getprior (rhs -> VSym.sym));
  1013.          }
  1014.       else Die ("Strange lists found\n");
  1015.     };
  1016.  
  1017. static void init_simp_arrays ()
  1018.     { int ix;
  1019.       local_xref = (int *) ckcalloc (uniquenr, sizeof (int));
  1020.       local_xref_trans = (int*) ckcalloc (uniquenr, sizeof (int));
  1021.       local_val = (val *) ckcalloc (uniquenr, sizeof (val));
  1022.       for (ix = 0; ix < uniquenr; ix++) local_xref [ix] = no_appear;
  1023.       for (ix = 0; ix < uniquenr; ix++) local_xref_trans [ix] = no_appear;
  1024.     };
  1025.  
  1026. static void do_transitive_closure ()
  1027.     { int localnr;
  1028.       for (localnr = 0; localnr < uniquenr; localnr++)
  1029.          if (local_xref [localnr] != no_appear)
  1030.             { int localnr2 = localnr;
  1031.           while (local_xref [localnr2] != must_appear)
  1032.              localnr2 = local_xref [localnr2];
  1033.           local_xref_trans [localnr] = localnr2;
  1034.         };
  1035.     };
  1036.  
  1037. static val simplify_val (v)
  1038.  val v;
  1039.     { switch (v -> tag)
  1040.          { case TAGVSym:
  1041.           { int nr = getprior (v -> VSym.sym);
  1042.             int nr2 = local_xref_trans [nr];
  1043.             if (nr2 == must_appear) return (rdup_val (v));
  1044.             return (rdup_val (local_val [nr2]));
  1045.           };
  1046.            case TAGVList:
  1047.           { register int ix;
  1048.             val_list vl = v -> VList.l;
  1049.             val_list nvl = new_val_list ();
  1050.             room_val_list (nvl, vl -> sz);
  1051.             nvl -> sz = vl -> sz;
  1052.             for (ix = 0; ix < vl -> sz; ix++)
  1053.                nvl -> arr[ix] = simplify_val (vl -> arr[ix]);
  1054.             return (new_VList (nvl));
  1055.           };
  1056.            case TAGVAtom:
  1057.           return (new_VAtom (rdup_orig (v -> VAtom.atorig),
  1058.                     rdup_symbol (v -> VAtom.atnm),
  1059.                     rdup_parval_list (v -> VAtom.atvpar),
  1060.                     simplify_val (v -> VAtom.atcpar)));
  1061.            case TAGVWhere:
  1062.            default: badtag (v -> tag);
  1063.          };
  1064.     };
  1065.  
  1066. static void try_add_simplified_def (d, ndefs)
  1067.  def d;
  1068.  def_list ndefs;
  1069.     { def ndef;
  1070.       val lhs = d -> DefCon.defcon;
  1071.       val rhs = d -> DefCon.conas;
  1072.       if (lhs -> tag == TAGVSym)
  1073.          { int nr = getprior (lhs -> VSym.sym);
  1074.            if (local_xref [nr] != must_appear) return;
  1075.          };
  1076.       if (lhs -> tag == TAGVList)
  1077.          { val_list vl = lhs -> VList.l;
  1078.            if (vl -> sz == 0) return;
  1079.          };
  1080.       ndef = new_DefCon (rdup_orig (d -> DefCon.conorig),
  1081.                 rdup_val (lhs),
  1082.                 simplify_val (rhs));
  1083.       app_def_list (ndefs, ndef);
  1084.     };
  1085.  
  1086. static val try_simplify_defs (org, v)
  1087.  orig org;
  1088.  val v;
  1089.     { register int ix;
  1090.       val trhs = rdup_val (v -> VWhere.wval);
  1091.       val nrhs;
  1092.       def_list odefs = v -> VWhere.wdefs;
  1093.       def_list ndefs = new_def_list ();
  1094.       init_simp_arrays ();
  1095.       mark_symbols_in_fc (org, newfc);
  1096.       for (ix = 0; ix < odefs -> sz; ix++)
  1097.          try_mark_in_def (odefs -> arr[ix]);
  1098.       do_transitive_closure ();
  1099.       for (ix = 0; ix < odefs -> sz; ix++)
  1100.          try_add_simplified_def (odefs -> arr[ix], ndefs);
  1101.       nrhs = simplify_val (trhs);
  1102.       return (new_VWhere (ndefs, nrhs));
  1103.     };
  1104.  
  1105. /*
  1106.    prepare and transform the values
  1107. */
  1108. static void prepare (dl)
  1109.  def_list dl;
  1110.     { def d, nd;
  1111.       val lambdaexp, newval, newval2, newval3, newval4, newval5;
  1112.       orig org;
  1113.       fprintf (stderr, "uflat2: preparing...\n");
  1114.       newdefs = new_def_list ();
  1115.       copy_basenamedefs (newdefs, dl);
  1116.       d = find_thedef (dl);
  1117.       org = rdup_orig (d -> DefVal.valorig);
  1118.       lambdaexp = d -> DefVal.valas;
  1119.       intyp = rdup_typ (d -> DefVal.valtyp -> TypUni.uityp);
  1120.       outtyp = rdup_typ (d -> DefVal.valtyp -> TypUni.uotyp);
  1121.       deffc  = rdup_formcon (lambdaexp -> VLambda.lpar);
  1122.       defval = prepare_val (lambdaexp -> VLambda.lval);
  1123.       prepare_formcon (deffc, intyp);
  1124.       prepare_types ();
  1125.       fprintf (stderr, "uflat2: transforming...\n");
  1126.       newval = make_all_names_unique (org);
  1127.       newval2 = merge_all_wheres (org, newval, outtyp);
  1128.       newval3 = try_unfold_atoms (newval2);
  1129.       newval4 = try_split_defs (newval3);
  1130.       newval5 = try_simplify_defs (org, newval4);
  1131.       if (orignames)
  1132.          { nd = new_DefVal (org, rdup_symbol (d -> DefVal.valnm),
  1133.                 rdup_typ (d -> DefVal. valtyp),
  1134.                 new_VLambda (rdup_formcon (deffc),
  1135.                     new_VWhere (rdup_def_list (fcdefs),
  1136.                         newval5)));
  1137.          }
  1138.       else
  1139.          { nd = new_DefVal (org, rdup_symbol (d -> DefVal.valnm),
  1140.                 rdup_typ (d -> DefVal. valtyp),
  1141.                 new_VLambda (rdup_formcon (newfc), newval5));
  1142.          };
  1143.       app_def_list (newdefs, nd);
  1144.       rfre_val (newval);
  1145.       rfre_val (newval2);
  1146.       rfre_val (newval3);
  1147.       rfre_val (newval4);
  1148.     };
  1149.  
  1150. /*
  1151.    Load all the definitions
  1152. */
  1153. static void load (f, dl)
  1154.  FILE *f;
  1155.  def_list *dl;
  1156.     { if (fscan_def_list (f, dl))
  1157.          { fprintf (stderr, "Read error: (%d): %s\n", tmlineno, tmerrmsg);
  1158.                exit (1);
  1159.          };
  1160.     };
  1161.  
  1162. main (argc, argv)
  1163.  int argc;
  1164.  char *argv [];
  1165.     { def_list all_defs;
  1166.       initsymbol ();
  1167.       scanargs (argc, argv);
  1168.       tmlineno = 1;
  1169.       load (infile, &all_defs);
  1170.       prepare (all_defs);
  1171.       fprint_def_list (outfile, newdefs);
  1172.       if (stat)
  1173.          { int ix;
  1174.            rfre_def_list (all_defs);
  1175.            rfre_formcon (deffc);
  1176.            rfre_val (defval);
  1177.            rfre_typ (intyp);
  1178.            rfre_typ (outtyp);
  1179.            for (ix=0; ix < procnr - proclowend; ix++)
  1180.           rfre_typ (ctypes[ix]);
  1181.            flushsymbol ();
  1182.            stat_ds (stderr);
  1183.            stat_string (stderr);
  1184.          };
  1185.     }
  1186.